home *** CD-ROM | disk | FTP | other *** search
/ Delphi 2 - Developers' Solutions / Delphi 2 Developers' Solutions.iso / dds / comps / goodies / delphi10 / prntrdlg / ccprnmgr.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-06-18  |  17.5 KB  |  513 lines
  1. unit Ccprnmgr;
  2.  
  3. interface
  4.  
  5. uses
  6.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  7.   Forms, Dialogs, StdCtrls, ExtCtrls, Buttons, Printers, DRWSUtl1, PPrevUn;
  8.  
  9. type
  10.   TCCPrintForm = class(TForm)
  11.     ComboBox1: TComboBox;
  12.     Label1: TLabel;
  13.     BitBtn1: TBitBtn;
  14.     BitBtn3: TBitBtn;
  15.     BitBtn4: TBitBtn;
  16.     Bevel1: TBevel;
  17.     Label2: TLabel;
  18.     Label3: TLabel;
  19.     Label4: TLabel;
  20.     Bevel2: TBevel;
  21.     Label5: TLabel;
  22.     Label6: TLabel;
  23.     Bevel3: TBevel;
  24.     ListBox1: TListBox;
  25.     Label7: TLabel;
  26.     BitBtn6: TBitBtn;
  27.     BitBtn7: TBitBtn;
  28.     BitBtn8: TBitBtn;
  29.     Label8: TLabel;
  30.     Label9: TLabel;
  31.     Label10: TLabel;
  32.     Label11: TLabel;
  33.     RadioGroup1: TRadioGroup;
  34.     BitBtn9: TBitBtn;
  35.     FontDialog1: TFontDialog;
  36.     BitBtn10: TBitBtn;
  37.     BitBtn11: TBitBtn;
  38.     BitBtn12: TBitBtn;
  39.     PrintDialog1: TPrintDialog;
  40.     PrinterSetupDialog1: TPrinterSetupDialog;
  41.     BitBtn2: TBitBtn;
  42.     procedure FormCreate(Sender: TObject);
  43.     procedure BitBtn1Click(Sender: TObject);
  44.     procedure BitBtn7Click(Sender: TObject);
  45.     procedure BitBtn9Click(Sender: TObject);
  46.     procedure RadioGroup1Click(Sender: TObject);
  47.     procedure BitBtn6Click(Sender: TObject);
  48.     procedure BitBtn4Click(Sender: TObject);
  49.     procedure BitBtn8Click(Sender: TObject);
  50.     procedure BitBtn10Click(Sender: TObject);
  51.     procedure BitBtn12Click(Sender: TObject);
  52.     procedure BitBtn11Click(Sender: TObject);
  53.     procedure BitBtn2Click(Sender: TObject);
  54.     procedure BitBtn3Click(Sender: TObject);
  55.   private
  56.     { Private declarations }
  57.   public
  58.     { Public declarations }
  59.     procedure HandlePrinting;
  60.     procedure DumpScreenToPrinter( PrintToFile : Boolean );
  61.     procedure HandlePrintPreview;
  62.   end;
  63.  
  64. var
  65.   CCPrintForm: TCCPrintForm;
  66.  
  67. implementation
  68.  
  69. {$R *.DFM}
  70.  
  71. procedure TCCPrintForm.HandlePrintPreview;
  72. var TheRatio : double;
  73.     TheMultiple,
  74.     RealWidth ,
  75.     RealHeight   : Integer;
  76.     TheBitmap : TBitmap;
  77.     ScreenDC : HDC;
  78.     TheResult : Boolean;
  79. begin
  80.   { Create the bitmap and put screen image in it }
  81.   TheBitmap := TBitmap.Create;
  82.   TheBitmap.Width := Screen.Width;
  83.   TheBitmap.Height := Screen.Height;
  84.   ScreenDC := GetDC( 0 );
  85.   TheResult := BitBlt( TheBitmap.Canvas.Handle , 0 , 0 , Screen.Width , Screen.Height ,
  86.           ScreenDC , 0 , 0 , SRCCOPY );
  87.   ReleaseDC( 0 , ScreenDC );
  88.   { This shows the position of a screen dump on the printed page }
  89.   PrintPreviewForm := TPrintPreviewForm.Create( Application );
  90.   TheMultiple := Round( Printer.PageWidth/Screen.Width ) - 1;
  91.   TheRatio := PrintPreviewForm.Panel2.Width/Printer.PageWidth;
  92.   RealWidth := Round( TheRatio * TheBitmap.Width * TheMultiple );
  93.   RealHeight := Round( TheRatio * TheBitmap.Height * TheMultiple );
  94.   PrintPreviewForm.Image1.Width := RealWidth;
  95.   PrintPreviewForm.Image1.Height := RealHeight;
  96.   PrintPreviewForm.Image1.Picture.Bitmap := TheBitmap;
  97.   PrintPreviewForm.ShowModal;
  98.   PrintPreviewForm.Free;
  99.   TheBitmap.Free;
  100. end;
  101.  
  102. procedure TCCPrintForm.DumpScreenToPrinter( PrintToFile : Boolean );
  103. var TheBitmap : TBitmap;
  104.     ScreenDC : HDC;
  105.     Info: PBitmapInfo;
  106.     InfoSize: Integer;
  107.     Image: Pointer;
  108.     ImageSize: Longint;
  109.     Bits: HBITMAP;
  110.     DIBWidth, DIBHeight: Longint;
  111.     PrintWidth, PrintHeight: Longint;
  112.     TheResult : Boolean;
  113.     PrinterMult : Integer;
  114.     OpenDialog1 : TOpenDialog;
  115. begin
  116.   { External try/except loop to get errors }
  117.   try
  118.     { Start the print }
  119.     if not PrintToFile then Printer.BeginDoc;
  120.     { Create the bitmap and put screen image in it }
  121.     TheBitmap := TBitmap.Create;
  122.     TheBitmap.Width := Screen.Width;
  123.     TheBitmap.Height := Screen.Height;
  124.     ScreenDC := GetDC( 0 );
  125.     TheResult := BitBlt( TheBitmap.Canvas.Handle , 0 , 0 , Screen.Width , Screen.Height ,
  126.             ScreenDC , 0 , 0 , SRCCOPY );
  127.     ReleaseDC( 0 , ScreenDC );
  128.     { Get the aspect ration printer to screen, less 1 for overruns }
  129.     PrinterMult := Round( Printer.PageWidth / Screen.Width ) - 1;
  130.     if PrintToFile then
  131.     begin
  132.       OpenDialog1 := TOpenDialog.Create( Application );
  133.       OpenDialog1.Filter := 'Windows Bitmaps|*.bmp|All Files|*.*';
  134.       OpenDialog1.Filename := '*.bmp';
  135.       OpenDialog1.Title := 'Save Screen Dump As...';
  136.       if OpenDialog1.Execute then TheBitmap.SaveToFile( OpenDialog1.FileName );
  137.       TheBitmap.Free;
  138.       OpenDialog1.Free;
  139.       exit;
  140.     end;
  141.     { Do a StretchDIBits due to a canvas bug in delphi printing }
  142.     Bits := TheBitmap.Handle;
  143.     GetDIBSizes(Bits, InfoSize, ImageSize);
  144.     Info := MemAlloc(InfoSize);
  145.     try
  146.       Image := MemAlloc(ImageSize);
  147.       try
  148.         GetDIB(Bits, 0, Info^, Image^);
  149.         with Info^.bmiHeader do
  150.         begin
  151.           DIBWidth := biWidth;
  152.           DIBHeight := biHeight;
  153.         end;
  154.         PrintWidth := DIBWidth * PrinterMult;
  155.         PrintHeight := DIBHeight * PrinterMult;
  156.         StretchDIBits(Printer.Canvas.Handle, 10 , 10 , PrintWidth, PrintHeight, 0, 0,
  157.          DIBWidth, DIBHeight, Image, Info^, DIB_RGB_COLORS, SRCCOPY);
  158.       finally
  159.           FreeMem(Image, ImageSize);
  160.       end;
  161.     finally
  162.       FreeMem(Info, InfoSize);
  163.     end;
  164.     TheBitmap.Free;
  165.     { Send the bitmap to the printer }
  166.     if not Printer.Aborted then Printer.EndDoc;
  167.   except
  168.     { Assume HandlePrint reraises exception }
  169.     On E:EPrinter do
  170.     begin
  171.       { Beep on error }
  172.       MessageBeep( MB_ICONEXCLAMATION );
  173.       { Set status label color to red }
  174.       Label6.Font.Color := clRed;
  175.       { Set the caption to the error message }
  176.       Label6.Caption := E.Message;
  177.       { If any exceptions occur chicken out and dump }
  178.       Printer.Abort;
  179.       exit;
  180.     end;
  181.     On E: Exception do
  182.     begin
  183.       raise;
  184.       exit;
  185.     end;
  186.   end;
  187. end;
  188.  
  189. procedure TCCPrintForm.HandlePrinting;
  190. var TheFile      : TextFile;    { Used to open text files     }
  191.     TheBitmap    : TBitmap;     { Used to open bitmap files   }
  192.     Counter_1 ,                 { Loop Counter for Selections }
  193.     Counter_2    : Integer;     { Loop Counter for lines      }
  194.     TheString    : String;      { Text file IO handler        }
  195.     TestString   : String;      { Used to check file extension}
  196.     Info         : PBitmapInfo; { Used to print bitmap        }
  197.     InfoSize     : Integer;     { Used to print bitmap        }
  198.     Image        : Pointer;     { Used to print bitmap        }
  199.     ImageSize    : Longint;     { Used to print bitmap        }
  200.     Bits         : HBITMAP;     { Used to print bitmap        }
  201.     DIBWidth ,                  { Used to print bitmap        }
  202.     DIBHeight    : Longint;     { Used to print bitmap        }
  203.     PrintWidth ,                { Used to print bitmap        }
  204.     PrintHeight  : Longint;     { Used to print bitmap        }
  205. begin
  206.   { Print text and bitmap files directly and shell all }
  207.   { other files out to windows to print, if possible.  }
  208.   for Counter_1 := 0 to Listbox1.Items.Count - 1 do
  209.   begin
  210.     { Allow checks for hitting abort button }
  211.     Application.ProcessMessages;
  212.     if Printer.Aborted then exit;
  213.     { Check for selected file in the listbox to do a print }
  214.     if ListBox1.Selected[ Counter_1 ] then
  215.     begin
  216.       { Check against extension of file selected }
  217.       TestString := Uppercase( ExtractFileExt( ListBox1.Items[ Counter_1 ] ));
  218.       if TestString = '.TXT' then
  219.       begin { Print out text files directly to demo method }
  220.         { Call begindoc method }
  221.         Printer.BeginDoc;
  222.         try
  223.           { Try to assign and open the file, barf if can't }
  224.           AssignFile( TheFile , ListBox1.Items[ Counter_1 ] );
  225.           Reset( TheFile );
  226.           { Set the lines printed counter }
  227.           Counter_2 := 1;
  228.           { Run to the end of the file }
  229.           while not EOF( TheFile ) do
  230.           begin
  231.             { Allow the user to abort }
  232.             Application.ProcessMessages;
  233.             if Printer.Aborted then
  234.             begin
  235.               { Display brief abort message }
  236.               Label6.Font.Color := clRed;
  237.               Label6.Caption := 'Aborting...';
  238.               Label6.Show;
  239.               { Go bye bye }
  240.               exit;
  241.             end;
  242.             { Do the actual printing with textout }
  243.             { Read the next line in               }
  244.             Readln( TheFile , TheString );
  245.             { Put it out down the page per line }
  246.             Printer.Canvas.TextOut( 10 , 20 +
  247.              ( Counter_2  * ( Printer.Canvas.TextHeight( 'W' ) + 5 )) ,
  248.               TheString );
  249.             { Increment the line counter and test for end of page }
  250.             Counter_2 := Counter_2 + 1;
  251.             if (( Counter_2 * ( Printer.Canvas.TextHeight( 'W' ) +
  252.              5 )) + 20 ) > ( Printer.PageHeight - 20 ) then
  253.             begin
  254.               { Send a form feed to printer and reset line counter }
  255.               Printer.NewPage;
  256.               Counter_2 := 1;
  257.             end;
  258.           end;
  259.           { Close the file being printed }
  260.           CloseFile( TheFile );
  261.         except
  262.           { Assume HandlePrint reraises exception }
  263.           On E:EPrinter do
  264.           begin
  265.             { Beep on error }
  266.             MessageBeep( MB_ICONEXCLAMATION );
  267.             { Set status label color to red }
  268.             Label6.Font.Color := clRed;
  269.             { Set the caption to the error message }
  270.             Label6.Caption := E.Message;
  271.             { If any exceptions occur chicken out and dump }
  272.             Printer.Abort;
  273.             exit;
  274.           end;
  275.         end;
  276.         { Call Enddoc method }
  277.         Printer.EndDoc;
  278.       end
  279.       else
  280.       begin
  281.         if TestString = '.BMP' then
  282.         begin { Print out bitmap files directly to demo method }
  283.           { If not graphics capabile signal error }
  284.           if Label9.Caption = 'Graphics Capable'
  285.           then
  286.           begin
  287.             { Otherwise create the bitmap and load the file }
  288.             TheBitmap := TBitmap.Create;
  289.             try
  290.               TheBitmap.LoadFromFile( ListBox1.Items[ Counter_1 ] );
  291.             except
  292.               { Abort on error }
  293.               raise;
  294.               exit;
  295.             end;
  296.             try
  297.               { Start the printing }
  298.               {Printer.BeginDoc;}
  299.               { Perform magic since normal canvas stuff won't work! }
  300.               with Printer, Canvas do
  301.               begin
  302.                 { Get a handle to the bitmap's data }
  303.                 Bits := TheBitmap.Handle;
  304.                 { Find out memory requirements }
  305.                 GetDIBSizes(Bits, InfoSize, ImageSize);
  306.                 { Get a pointer to enough memory for structure }
  307.                 Info := MemAlloc(InfoSize);
  308.                 try
  309.                   { Now try to hold the bits }
  310.                   Image := MemAlloc(ImageSize);
  311.                   try
  312.                     { And conver them to Device Independent }
  313.                     GetDIB(Bits, 0, Info^, Image^);
  314.                     with Info^.bmiHeader do
  315.                     begin
  316.                       { Get width and height when done }
  317.                       DIBWidth := biWidth;
  318.                       DIBHeight := biHeight;
  319.                     end;
  320.                     { Set these to enlarge but could scale }
  321.                     PrintWidth := DIBWidth * 3;
  322.                     PrintHeight := DIBHeight * 3;
  323.                     { Do actual print via StretchDIBits API call }
  324.                     StretchDIBits(Canvas.Handle, 20 , 20 , PrintWidth,
  325.                      PrintHeight, 0, 0, DIBWidth, DIBHeight, Image,
  326.                       Info^, DIB_RGB_COLORS, SRCCOPY);
  327.                   finally
  328.                     { Release memory regardless }
  329.                     FreeMem(Image, ImageSize);
  330.                   end;
  331.                 finally
  332.                   { Release more memory regardless }
  333.                   FreeMem(Info, InfoSize);
  334.                   { Free the bitmap }
  335.                   TheBitmap.Free;
  336.                 end;
  337.               end;
  338.               { End the printing }
  339.               Printer.EndDoc;
  340.             except
  341.               { Assume HandlePrint reraises exception }
  342.               On E:EPrinter do
  343.               begin
  344.                 { Beep on error }
  345.                 MessageBeep( MB_ICONEXCLAMATION );
  346.                 { Set status label color to red }
  347.                 Label6.Font.Color := clRed;
  348.                 { Set the caption to the error message }
  349.                 Label6.Caption := E.Message;
  350.                 { If any exceptions occur chicken out and dump }
  351.                 Printer.Abort;
  352.                 exit;
  353.               end;
  354.             end;
  355.           end
  356.           { Complain about printing to nonraster device! }
  357.           else MessageDlg( 'Cannot Print A Bitmap On Non-Graphics Printer!',
  358.            mtError, [mbOK],0 );
  359.         end
  360.         else
  361.         begin
  362.           { Otherwise try to shell out to windows to print complex file }
  363.           if not ShellExec( ExpandFileName( ListBox1.Items[ Counter_1 ] )
  364.             , '' , '', true , SW_SHOWMINIMIZED , true ) then
  365.             MessageDlg('Could not Print ' + ListBox1.Items[ Counter_1 ] ,
  366.              mtError, [mbOK], 0);
  367.         end;
  368.       end;
  369.     end;
  370.   end;
  371. end;
  372.  
  373. procedure TCCPrintForm.FormCreate(Sender: TObject);
  374. begin
  375.   { Clear the combobox and assign the available printers }
  376.   Combobox1.Clear;
  377.   Combobox1.Items.Assign( Printer.Printers );
  378.   Combobox1.Itemindex := Printer.PrinterIndex;
  379.   { Display currently active printer }
  380.   Label4.Caption := Printer.Printers[ Printer.PrinterIndex ];
  381.   { Display resolution of currently active printer }
  382.   Label11.Caption := 'Width: ' + InttoStr( Printer.PageWidth ) +
  383.    ' Height: ' + IntToStr( Printer.PageHeight );
  384.   { Display orientation of currently active printer }
  385.   case Printer.Orientation of
  386.     poPortrait  : RadioGroup1.ItemIndex := 0;
  387.     poLandscape : RadioGroup1.ItemIndex := 1;
  388.   end;
  389.   { Set label for status }
  390.   Label6.Font.Color := clBlack;
  391.   Label6.Caption := 'Idle';
  392.   { Determine basic device capabilities of the selected printer }
  393.   if GetDeviceCaps( Printer.Handle , TECHNOLOGY ) = DT_RASPRINTER then
  394.    Label9.Caption := 'Graphics Capable' else Label9.Caption := 'Character Device';
  395.   if GetDeviceCaps( Printer.Handle , BITSPIXEL ) > 1 then
  396.    Label8.Caption := 'Color Capable' else Label8.Caption := 'Monochrome';
  397.   Label10.Caption := 'Resolution: ' +
  398.    IntToStr( GetDeviceCaps( Printer.Handle , LOGPIXELSX )) + ' dpi';
  399. end;
  400.  
  401. procedure TCCPrintForm.BitBtn1Click(Sender: TObject);
  402. begin
  403.   { Set the Default printer to be the selection of the combobox }
  404.   Printer.PrinterIndex := ComboBox1.ItemIndex;
  405.   { And cleverly reset the display! }
  406.   FormCreate( Self );
  407. end;
  408.  
  409. procedure TCCPrintForm.BitBtn7Click(Sender: TObject);
  410. begin
  411.   { This just runs the printer setup dialog }
  412.   PrinterSetupDialog1.Execute;
  413. end;
  414.  
  415. procedure TCCPrintForm.BitBtn9Click(Sender: TObject);
  416. begin
  417.   { This just displays available fonts for the printer }
  418.   if FontDialog1.Execute then Printer.Canvas.Font := FontDialog1.Font;
  419. end;
  420.  
  421. procedure TCCPrintForm.RadioGroup1Click(Sender: TObject);
  422. begin
  423.   { Set the printer orientation based on the radiogroup itemindex }
  424.   case RadioGroup1.ItemIndex of
  425.     0 : Printer.Orientation := poPortrait;
  426.     1 : Printer.Orientation := poLandscape;
  427.   end;
  428. end;
  429.  
  430. procedure TCCPrintForm.BitBtn6Click(Sender: TObject);
  431. begin
  432.   { If execute print dialog then call HandlePrint method and deal with exceptions }
  433.   if PrintDialog1.Execute then
  434.   begin
  435.     { Reset Label font color }
  436.     Label6.Font.Color := clBlack;
  437.     { Change status label to printing }
  438.     Label6.Caption := 'Printing...';
  439.     { Call HandlePrinting Method }
  440.     HandlePrinting;
  441.     { Reset the display to indicate printing not in progress }
  442.     if Label6.Caption = 'Printing...' then Label6.Caption := 'Idle';
  443.   end;
  444. end;
  445.  
  446. procedure TCCPrintForm.BitBtn4Click(Sender: TObject);
  447. begin
  448.   { If already printing do abort }
  449.   if Printer.Printing then
  450.   begin
  451.     { call abort method }
  452.     Printer.Abort;
  453.     { Reset status label }
  454.     Label6.Font.Color := clBlack;
  455.     Label6.Caption := 'Aborted...';
  456.   end;
  457. end;
  458.  
  459. procedure TCCPrintForm.BitBtn8Click(Sender: TObject);
  460. begin
  461.   if not ShellExec( 'C:\WINDOWS\PRINTMAN.EXE', '' , '', false ,
  462.    SW_SHOWNORMAL , false ) then
  463.     MessageDlg('Could not locate Print Manager!', mtError, [mbOK], 0);
  464. end;
  465.  
  466. procedure TCCPrintForm.BitBtn10Click(Sender: TObject);
  467. begin
  468.   if PrintDialog1.Execute then
  469.   begin
  470.     { Reset Label font color }
  471.     Label6.Font.Color := clBlack;
  472.     { Change status label to printing }
  473.     Label6.Caption := 'Printing...';
  474.     { Call Print Screen Method }
  475.     DumpScreenToPrinter( false );
  476.     { Reset the display to indicate printing not in progress }
  477.     if Label6.Caption = 'Printing...' then Label6.Caption := 'Idle';
  478.   end;
  479. end;
  480.  
  481. procedure TCCPrintForm.BitBtn12Click(Sender: TObject);
  482. begin
  483.   if PrintDialog1.Execute then
  484.   begin
  485.     { Reset Label font color }
  486.     Label6.Font.Color := clBlack;
  487.     { Change status label to printing }
  488.     Label6.Caption := 'Printing...';
  489.     { Call Print Screen Method }
  490.     DumpScreenToPrinter( PrintDialog1.PrintToFile );
  491.     { Reset the display to indicate printing not in progress }
  492.     if Label6.Caption = 'Printing...' then Label6.Caption := 'Idle';
  493.   end;
  494. end;
  495.  
  496. procedure TCCPrintForm.BitBtn11Click(Sender: TObject);
  497. begin
  498.   { Call the HPP routine }
  499.   HandlePrintPreview;
  500. end;
  501.  
  502. procedure TCCPrintForm.BitBtn2Click(Sender: TObject);
  503. begin
  504.   Application.HelpJump('Main_Dialog');
  505. end;
  506.  
  507. procedure TCCPrintForm.BitBtn3Click(Sender: TObject);
  508. begin
  509.   Close;
  510. end;
  511.  
  512. end.
  513.